home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / MISC.SWG / 0015_SUNDRY.PAS.pas < prev    next >
Pascal/Delphi Source File  |  1993-05-28  |  13KB  |  482 lines
  1. Unit sundry;
  2.  
  3. Interface
  4.  
  5. Uses
  6.   Dos,
  7.   sCrt,
  8.   Strings;
  9.  
  10. Type
  11.   LongWds = Record
  12.               loWord,
  13.               hiWord : Word;
  14.             end;
  15.   ica_rec = Record
  16.               Case Integer of
  17.                 0: (Bytes   : Array[0..15] of Byte);
  18.                 1: (Words   : Array[0..7] of Word);
  19.                 2: (Integers: Array[0..7] of Integer);
  20.                 3: (strg    : String[15]);
  21.                 4: (longs   : Array[0..3] of LongInt);
  22.                 5: (dummy   : String[13]; chksum: Integer);
  23.                 6: (mix     : Byte; wds : Word; lng : LongInt);
  24.             end;
  25. {-This simply creates a Variant Record which is mapped to 0000:04F0
  26.   which is the intra-applications communications area in the bios area
  27.   of memory. A Program may make use of any of the 16 Bytes in this area
  28.   and be assured that Dos and the bios will not interfere With it. This
  29.   means that it can be effectively used to pass values/inFormation
  30.   between different Programs. It can conceivably be used to store
  31.   inFormation from an application, then terminate from that application,
  32.   run several other Programs, and then have another Program use the
  33.   stored inFormation. As the area can be used by any Program, it is wise
  34.   to incorporate a checksum to ensure that the intermediate applications
  35.   have not altered any values. It is of most use when executing child
  36.   processes or passing values between related Programs that are run
  37.   consecutively.}
  38.  
  39.   IOproc = Procedure(derror:Byte; msg : String);
  40.  
  41. Const
  42.   ValidChars : String[40] = ' ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890-'+#39;
  43.   HexChars : Array[0..15] of Char = '0123456789ABCDEF';
  44.  
  45. Var
  46.   ica : ica_rec Absolute $0000:$04f0;
  47.   FilePosition : LongInt;
  48. (*  OldRecSize   : Word; *)
  49.   TempStr      : String;
  50.  
  51. Procedure CheckIO(Error_action : IOproc; msg : String);
  52.  
  53. Function CompressStr(Var n): String;
  54.   {-Will Compress 3 alpha-numeric Bytes into 2 Bytes}
  55.  
  56. Function DeCompress(Var s): String;
  57.   {-DeCompresses a String Compressed by CompressStr}
  58.  
  59. Function NumbofElements(Var s; size : Word): Word;
  60.   {-returns the number of active elements in a set}
  61.  
  62. Function PrinterStatus : Byte;
  63.   {-Gets the Printer status}
  64.  
  65. Function PrinterReady(Var b : Byte): Boolean;
  66.  
  67. Function TestBbit(n,b: Byte): Boolean;
  68. Function TestWbit(Var n; b: Byte): Boolean;
  69. Function TestLbit(n: LongInt; b: Byte): Boolean;
  70.  
  71. Procedure SetBbit(Var n: Byte; b: Byte);
  72. Procedure SetWbit(Var n; b: Byte);
  73. Procedure SetLbit(Var n: LongInt; b: Byte);
  74.  
  75. Procedure ResetBbit(Var n: Byte; b: Byte);
  76. Procedure ResetWbit(Var n; b: Byte);
  77. Procedure ResetLbit(Var n: LongInt; b: Byte);
  78.  
  79. Function right(Var s; n : Byte): String;
  80. Function left(Var s; n : Byte): String;
  81. Function shleft(Var s; n : Byte): String;
  82. Function nExtStr(Var s1; s2 : String; n : Byte): String;
  83. Procedure WriteAtCr(st: String; col,row: Byte);
  84. Procedure WriteLnAtCr(st: String; col,row: Byte);
  85. Procedure WriteLNCenter(st: String; width: Byte);
  86. Procedure WriteCenter(st: String; width: Byte);
  87. Procedure GotoCR(col,row: Byte);
  88.  
  89.   {-These Functions and Procedures Unit provides the means to do random
  90.     access reads on Text Files.  }
  91.  
  92. Function Exist(fn : String) : Boolean;
  93.  
  94. Function Asc2Str(Var s; max: Byte): String;
  95.  
  96. Procedure DisableBlink(State:Boolean);
  97.  
  98. Function Byte2Hex(numb : Byte) : String;
  99.  
  100. Function Numb2Hex(Var numb) : String;
  101.  
  102. Function Long2Hex(long : LongInt): String;
  103.  
  104. Function Hex2Byte(HexStr : String) : Byte;
  105.  
  106. Function Hex2Word(HexStr : String) : Word;
  107.  
  108. Function Hex2Integer(HexStr : String) : Integer;
  109.  
  110. Function Hex2Long(HexStr : String) : LongInt;
  111.  
  112. {======================================================================}
  113.  
  114.  
  115. Implementation
  116.  
  117. Procedure CheckIO(error_action : IOproc;msg : String);
  118.   Var c : Word;
  119.   begin
  120.     c := Ioresult;
  121.     if c <> 0 then error_action(c,msg);
  122.   end;
  123.  
  124.  
  125. {$F+}
  126. Procedure ReportError(c : Byte; st : String);
  127.   begin
  128.     Writeln('I/O Error ',c);
  129.     Writeln(st);
  130.     halt(c);
  131.   end;
  132. {$F-}
  133.  
  134. Function StUpCase(Str : String) : String;
  135. Var
  136.   Count : Integer;
  137. begin
  138.   For Count := 1 to Length(Str) do
  139.     Str[Count] := UpCase(Str[Count]);
  140.   StUpCase := Str;
  141. end;
  142.  
  143.  
  144.  
  145. Function CompressStr(Var n): String;
  146.   Var
  147.     S      : String Absolute n;
  148.     InStr  : String;
  149.     len    : Byte Absolute InStr;
  150.     Compstr: Record
  151.               Case Byte of
  152.                 0: (Outlen  : Byte;
  153.                     OutArray: Array[0..84] of Word);
  154.                 1: (Out     : String[170]);
  155.              end;
  156.     temp,
  157.     x,
  158.     count : Word;
  159.   begin
  160.     FillChar(InStr,256,32);
  161.     InStr := S;
  162.     len   := (len + 2) div 3 * 3;
  163.     FillChar(CompStr.Out,171,0);
  164.     InStr := StUpCase(InStr);
  165.     x := 1; count := 0;
  166.     While x <= len do begin
  167.       temp  := pos(InStr[x+2],ValidChars);
  168.       inc(temp,pos(InStr[x+1],ValidChars) * 40);
  169.       inc(temp,pos(InStr[x],ValidChars) * 1600);
  170.       inc(x,3);
  171.       CompStr.OutArray[count] := temp;
  172.       inc(count);
  173.     end;
  174.     CompStr.Outlen := count shl 1;
  175.     CompressStr := CompStr.Out;
  176.   end;  {-CompressStr}
  177.  
  178. Function DeCompress(Var s): String;
  179.   Var
  180.     CompStr : Record
  181.                 clen : Byte;
  182.                 arry : Array[0..84] of Word;
  183.               end Absolute s;
  184.     x,
  185.     count,
  186.     temp    : Word;
  187.   begin
  188.     With CompStr do begin
  189.       DeCompress[0] := Char((clen shr 1) * 3);
  190.       x := 0; count := 1;
  191.       While x <= clen shr 1 do begin
  192.         temp := arry[x] div 1600;
  193.         dec(arry[x],temp*1600);
  194.         DeCompress[count] := ValidChars[temp];
  195.         temp := arry[x] div 40;
  196.         dec(arry[x],temp*40);
  197.         DeCompress[count+1] := ValidChars[temp];
  198.         temp := arry[x];
  199.         DeCompress[count+2] := ValidChars[temp];
  200.         inc(count,3);
  201.         inc(x);
  202.       end;
  203.     end;
  204.   end;
  205.  
  206. Function NumbofElements(Var s; size : Word): Word;
  207.  {-The Variable s can be any set Type and size is the Sizeof(s)}
  208.   Var
  209.     TheSet : Array[1..32] of Byte Absolute s;
  210.     count,x,y : Word;
  211.   begin
  212.     count := 0;
  213.     For x := 1 to size do
  214.       For y := 0 to 7 do
  215.         inc(count, 1 and (TheSet[x] shr y));
  216.     NumbofElements := count;
  217.   end;
  218.  
  219. Function PrinterStatus : Byte;
  220.    Var regs   : Registers; {-from the Dos Unit                         }
  221.    begin
  222.      With regs do begin
  223.        dx := 0;            {-The Printer number   LPT2 = 1             }
  224.        ax := $0200;        {-The Function code For service wanted      }
  225.        intr($17,regs);     {-$17= ROM bios int to return Printer status}
  226.        PrinterStatus := ah;{-Bit 0 set = timed out                     }
  227.      end;                  {     1     = unused                        }
  228.    end;                    {     2     = unused                        }
  229.                            {     3     = I/O error                     }
  230.                            {     4     = Printer selected              }
  231.                            {     5     = out of paper                  }
  232.                            {     6     = acknowledge                   }
  233.                            {     7     = Printer not busy              }
  234.  
  235. Function PrinterReady(Var b : Byte): Boolean;
  236.   begin
  237.     b := PrinterStatus;
  238.     PrinterReady := (b = $90) {-This may Vary between Printers}
  239.   end;
  240.  
  241. Function TestBbit(n,b: Byte): Boolean;
  242.   begin
  243.     TestBbit := odd(n shr b);
  244.   end;
  245.  
  246. Function TestWbit(Var n; b: Byte): Boolean;
  247.   Var t: Word Absolute n;
  248.   begin
  249.     if b < 16 then
  250.       TestWbit := odd(t shr b);
  251.   end;
  252.  
  253. Function TestLbit(n: LongInt; b: Byte): Boolean;
  254.   begin
  255.     if b < 32 then
  256.       TestLbit := odd(n shr b);
  257.   end;
  258.  
  259. Procedure SetBbit(Var n: Byte; b: Byte);
  260.   begin
  261.     if b < 8 then
  262.       n := n or (1 shl b);
  263.   end;
  264.  
  265. Procedure SetWbit(Var n; b: Byte);
  266.   Var t : Word Absolute n; {-this allows either a Word or Integer}
  267.   begin
  268.     if b < 16 then
  269.       t := t or (1 shl b);
  270.   end;
  271.  
  272. Procedure SetLbit(Var n: LongInt; b: Byte);
  273.   begin
  274.     if b < 32 then
  275.       n := n or (LongInt(1) shl b);
  276.   end;
  277.  
  278. Procedure ResetBbit(Var n: Byte; b: Byte);
  279.   begin
  280.     if b < 8 then
  281.       n := n and not (1 shl b);
  282.   end;
  283.  
  284. Procedure ResetWbit(Var n; b: Byte);
  285.   Var t: Word Absolute n;
  286.   begin
  287.     if b < 16 then
  288.       t := t and not (1 shl b);
  289.   end;
  290.  
  291. Procedure ResetLbit(Var n: LongInt; b: Byte);
  292.   begin
  293.     if b < 32 then
  294.       n := n and not (LongInt(1) shl b);
  295.   end;
  296.  
  297. Function right(Var s; n : Byte): String;
  298.   Var
  299.     st : String Absolute s;
  300.     len: Byte Absolute s;
  301.   begin
  302.     if n >= len then right := st else
  303.     right := copy(st,len+1-n,n);
  304.   end;
  305.  
  306. Function shleft(Var s; n : Byte): String;
  307.   Var
  308.     st   : String Absolute s;
  309.     stlen: Byte Absolute s;
  310.     temp : String;
  311.     len  : Byte Absolute temp;
  312.   begin
  313.     if n < stlen then begin
  314.       move(st[n+1],temp[1],255);
  315.       len := stlen - n;
  316.       shleft := temp;
  317.     end;
  318.   end;
  319.  
  320. Function left(Var s; n : Byte): String;
  321.   Var
  322.     st  : String Absolute s;
  323.     temp: String;
  324.     len : Byte Absolute temp;
  325.   begin
  326.     temp := st;
  327.     if n < len then len := n;
  328.     left := temp;
  329.   end;
  330.  
  331. Function nExtStr(Var s1;s2 : String; n : Byte): String;
  332.   Var
  333.     main   : String Absolute s1;
  334.     second : String Absolute s2;
  335.     len    : Byte Absolute s2;
  336.   begin
  337.     nExtStr := copy(main,pos(second,main)+len,n);
  338.   end;
  339.  
  340. Procedure WriteAtCr(st: String; col,row: Byte);
  341.   begin
  342.     GotoXY(col,row);
  343.     Write(st);
  344.   end;
  345.  
  346.  
  347. Procedure WriteLnAtCr(st: String; col,row: Byte);
  348.   begin
  349.     GotoXY(col,row);
  350.     Writeln(st);
  351.   end;
  352.  
  353. Function Charstr(ch : Char; by : Byte) : String;
  354. Var
  355.   Str : String;
  356.   Count : Integer;
  357. begin
  358.   Str := '';
  359.   For Count := 1 to by do
  360.     Str := Str + ch;
  361.   CharStr := Str;
  362. end;
  363.  
  364.  
  365. Procedure WriteLnCenter(st: String; width: Byte);
  366.   begin
  367.     TempStr := CharStr(' ',(width div 2) - succ((length(st) div 2)));
  368.     st      := TempStr + st;
  369.     Writeln(st);
  370.   end;
  371.  
  372. Procedure WriteCenter(st: String; width: Byte);
  373.   begin
  374.     TempStr := CharStr(' ',(width div 2)-succ((length(st) div 2)));
  375.     st      := TempStr + st;
  376.     Write(st);
  377.   end;
  378.  
  379. Procedure GotoCR(col,row: Byte);
  380.   begin
  381.     GotoXY(col,row);
  382.   end;
  383.  
  384. Function Exist(fn : String): Boolean;
  385.   Var
  386.     f         : File;
  387.     OldMode   : Byte;
  388.   begin
  389.     OldMode := FileMode;
  390.     FileMode:= 0;
  391.     assign(f,fn);
  392.     {$I-}  reset(f,1); {$I+}
  393.     if Ioresult = 0 then begin
  394.       close(f);
  395.       Exist := True;
  396.     end
  397.     else
  398.       Exist := False;
  399.     FileMode:= OldMode;
  400.   end; {-Exist}
  401.  
  402. Function Asc2Str(Var s; max: Byte): String;
  403.   Var stArray : Array[0..255] of Byte Absolute s;
  404.       st      : String;
  405.       len     : Byte Absolute st;
  406.   begin
  407.     move(stArray[0],st[1],255);
  408.     len := max;
  409.     len := (max + Word(1)) * ord(pos(#0,st) = 0) + pos(#0,st)-1;
  410.     Asc2Str := st;
  411.   end;
  412.  
  413.  
  414. Procedure DisableBlink(state : Boolean);
  415.    { DisableBlink(True) allows use of upper eight colors as background }
  416.    { colours. DisableBlink(False) restores the normal mode and should  }
  417.    { be called beFore Program Exit                                     }
  418. Var
  419.    regs : Registers;
  420. begin
  421.   With regs do
  422.   begin
  423.     ax := $1003;
  424.     bl := ord(not(state));
  425.   end;
  426.   intr($10,regs);
  427. end;  { DisableBlink }
  428.  
  429. Function Byte2Hex(numb : Byte) : String;
  430.   begin
  431.     Byte2Hex[0] := #2;
  432.     Byte2Hex[1] := HexChars[numb shr  4];
  433.     Byte2Hex[2] := HexChars[numb and 15];
  434.   end;
  435.  
  436. Function Numb2Hex(Var numb) : String;
  437.   { converts an Integer or a Word to a String. Using an unTyped
  438.     argument makes this possible. }
  439.   Var n : Word Absolute numb;
  440.   begin
  441.     Numb2Hex := Byte2Hex(hi(n))+Byte2Hex(lo(n));
  442.   end;
  443.  
  444. Function Long2Hex(long : LongInt): String;
  445.   begin
  446.     With LongWds(long) do { Type casting makes the split up easy}
  447.       Long2Hex := Numb2Hex(hiWord) + Numb2Hex(loWord);
  448.   end;
  449.  
  450. Function Hex2Byte(HexStr : String) : Byte;
  451.   begin
  452.     Hex2Byte := pos(UpCase(HexStr[2]),HexChars)-1  +
  453.                ((pos(UpCase(HexStr[1]),HexChars))-1) shl  4 { *  16}
  454.   end;
  455.  
  456. Function Hex2Word(HexStr : String) : Word;
  457.   { This requires that the String passed is a True hex String  of 4
  458.     Chars and not in a Format like $FDE0 }
  459.   begin
  460.     Hex2Word := pos(UpCase(HexStr[4]),HexChars)-1  +
  461.                ((pos(UpCase(HexStr[3]),HexChars))-1) shl  4 + { *  16}
  462.                ((pos(UpCase(HexStr[2]),HexChars))-1) shl  8 + { * 256}
  463.                ((pos(UpCase(HexStr[1]),HexChars))-1) shl 12;  { *4096}
  464.   end;
  465.  
  466. Function Hex2Integer(HexStr : String) : Integer;
  467.   begin
  468.     Hex2Integer := Integer(Hex2Word(HexStr));
  469.   end;
  470.  
  471. Function Hex2Long(HexStr : String) : LongInt;
  472.   Var Long : LongWds;
  473.   begin
  474.     Long.hiWord := Hex2Word(copy(HexStr,1,4));
  475.     Long.loWord := Hex2Word(copy(HexStr,5,4));
  476.     Hex2Long := LongInt(Long);
  477.   end;
  478.  
  479. begin
  480.   FilePosition := 0;
  481. end.
  482.